PsL Monthly 1993 December/PSL Monthly Shareware CD-ROM (December 1993).iso/prgmming/dos/pascal/qpf.com/QPF.PAS

Pascal/Delphi Source File | 1990-10-28 | 15.6 KB | 683 lines

PROGRAM QPF;
{$A-}    {Disable Word Alignment}
{$B-}    {Short Circuit Boolean}
{$D-}    {Disable DEBUG Info}
{$R-}    {Disable Range Checking}
{$S-}    {Disable Stack Checking}
{$V-}    {Disable VAR String Checking}
{$I-}    {Disable I/O Checking}

{ --------------------------------------------------------
Purpose : Fixup PASCAL words into a standard format.
Author    : Greg Tesch
History    : 12/14/89    Initial Version
---------------------------------------------------------- }

USES Dos;

CONST
    IdentSet : SET OF Char = ['A'..'Z', 'a'..'z', '_'];
    DelimSet : SET OF Char = ['('..'/',':'..'>','@','[',']','^','{','}'];
    LiteralSet : SET OF Char = [#39,'$','#'];
    DigitSet : SET OF Char = ['0'..'9'];
    HexSet : SET OF Char = ['0'..'9','A'..'F','a'..'f'];
    Quote = '''';

TYPE
    StmtPtr = ^StmtRec;
    StmtRec = RECORD
        Next : StmtPtr;
        Stmt : STRING;
    END;
    Tokens = (Identifier, Literal, Other);
    SmallStr = STRING[15];                { Small String For Arrays }

VAR
    InFileName,OutFileName : DirStr;    { Input/Output File names }
    Token : STRING;                        { Global Token Variable }
    TokenType : Tokens;                    { Type of Token (Token) is }
    ProgStmts : StmtPtr;                { Pointer To Stored Program }
    CodeStmts : StmtPtr;                { Pointer To Stored Code }
    SHrs,SMin,SSec,SHnd : Word;            { Start Times }
    LineCnt : Word;                        { Lines Processed }

FUNCTION UpperStr(StrArg : STRING) : STRING;

    VAR
        i : Word;

    BEGIN
        FOR  i := 1 TO Length(StrArg) DO
            StrArg[i] := UpCase(StrArg[i]);
        UpperStr := StrArg;
    END;

FUNCTION TokenMatch (VAR Token : STRING; VAR ArrArg;
                     ArrSize, Shortest, Longest : Word) : Boolean;
    TYPE
        ArgTyp = ARRAY [1..150] OF SmallStr;

    VAR
        i, j : Word;
        TokenLn : Word;
        TokStr : STRING;
        Ch : Char;

    BEGIN
        TokenLn := Length(Token);
        TokStr := UpperStr(Token);
        TokenMatch := False;
        i := 1;

        IF (TokenLn >= Shortest) AND (TokenLn <= Longest) THEN
            REPEAT
                Ch := SmallStr(ArgTyp(ArrArg)[i])[1];
                Ch := UpCase(Ch);
                IF (TokStr[1] = Ch) THEN
                    IF ( Length(ArgTyp(ArrArg)[i]) = TokenLn ) AND
                       ( TokStr = UpperStr(ArgTyp(ArrArg)[i]) ) THEN
                        BEGIN
                            Token := ArgTyp(ArrArg)[i];
                            TokenMatch := True;
                            Exit;
                        END;
                Inc(i);
            UNTIL (i > ArrSize) OR (Ch > TokStr[1]);
    END;

FUNCTION IsKeyWord(VAR Token : STRING) : Boolean;

    CONST
        KeyWordCnt = 52;                    { Number Of KeyWords }
        Shortest = 2;                        { Shortest KeyWord Length }
        Longest = 14;                        { Longest Keyword Length }

    TYPE
        KeyWordArray = ARRAY [1..KeyWordCnt] OF SmallStr;

    CONST
        KeyWords : KeyWordArray = (
        'ABSOLUTE',    'AND',        'ARRAY',    'BEGIN',    'CASE',
        'CONST',    'CSTRING',    'DIV',        'DO',        'DOWNTO',
        'ELSE',        'END',        'EXTERNAL',    'FILE',        'FOR',
        'FORWARD',    'FUNCTION',    'GOTO',        'IF',        'IMPLEMENTATION',
        'IN',        'INHERITED','INLINE',    'INTERFACE','INTERRUPT',
        'LABEL',    'MOD',        'NIL',        'NOT',        'OBJECT',
        'OF',        'OR',        'OVERRIDE',    'PACKED',    'PROCEDURE',
        'PROGRAM',    'RECORD',    'REPEAT',    'SET',        'SHL',
        'SHR',        'STRING',    'THEN',        'TO',        'TYPE',
        'UNIT',        'UNTIL',    'USES',        'VAR',        'WHILE',
        'WITH',        'XOR' );

    BEGIN
        IsKeyWord :=
            TokenMatch(Token, KeyWords, KeyWordCnt, Shortest, Longest);
    END;

FUNCTION IsDataType (VAR Token : STRING) : Boolean;

    CONST
        DataTypeCnt = 24;                    { Number Of DataTypes }
        Shortest = 4;                        { Shortest DataType Length }
        Longest = 9;                        { Longest DataType Length }

    TYPE
        DataTypeArray = ARRAY [1..DataTypeCnt] OF SmallStr;

    CONST
        DataTypes : DataTypeArray = (
        'Boolean',    'Byte',        'Char',        'Comp',        'ComStr',
        'DateTime',    'DirStr',    'Double',    'Extended',    'ExtStr',
        'FileRec',    'Integer',    'LongInt',    'NameStr',    'PathStr',
        'Pointer',    'Real',        'Registers','SearchRec','Single',
        'Text',        'TextBuf',    'TextRec',    'Word');

    BEGIN
        IsDataType :=
            TokenMatch(Token, DataTypes, DataTypeCnt, Shortest, Longest);
    END;

FUNCTION IsConst (VAR Token : STRING) : Boolean;

    CONST
        ConstCnt = 57;                        { Number Of Constants }
        Shortest = 3;
        Longest = 12;

    TYPE
        ConstArray = ARRAY[1..ConstCnt] OF SmallStr;

    CONST
        Constants : ConstArray = (
        'AnyFile',    'Archive',    'Black',    'Blink',    'Blue',
        'Brown',    'BW40',        'BW80',        'C40',        'C80',
        'CO40',        'CO80',        'Cyan',        'DarkGray',    'Directory',
        'ErrorAddr','ExitCode',    'ExitProc',    'False',    'FAuxiliary',
        'FCarry',    'FileMode',    'FMClosed',    'FMInOut',    'FMInput',
        'FMOutput',    'Font8x8',    'FOverflow','FParity',    'FreeMin',
        'FreePtr',    'FSign',    'FZero',    'Green',    'HeapError',
        'HeapOrg',    'HeapPtr',    'Hidden',    'InOutRes',    'LightBlue',
        'LightCyan','LightGray','LightGreen','LightMagenta','LightRed',
        'Magenta',    'Mono',        'PrefixSeg','RandSeed',    'ReadOnly',
        'Red',        'StackLimit','SysFile',    'True',        'VolumeID',
        'White',    'Yellow');

    BEGIN
        IsConst :=
            TokenMatch(Token, Constants, ConstCnt, Shortest, Longest);
    END;

FUNCTION IsFuncProc (VAR Token : STRING) : Boolean;

    CONST
        FuncProcCnt = 142;                    { Number Of Functions }
        Shortest = 2;
        Longest = 14;

    TYPE
        FuncProcArray = ARRAY [1..FuncProcCnt] OF SmallStr;

    CONST
        FuncProcs : FuncProcArray = (
        'Abs',        'Addr',        'Append',    'ArcTan',    'Assign',
        'AssignCrt','BlockRead','BlockWrite','ChDir',    'Chr',
        'Close',    'ClrEol',    'ClrScr',    'Concat',    'Copy',
        'Cos',        'CSeg',        'Dec',        'Delay',    'Delete',
        'DelLine',    'DiskFree',    'DiskSize',    'Dispose',    'DosExitCode',
        'DosVersion','DSeg',    'EnvCount',    'EnvStr',    'Eof',
        'Eoln',        'Erase',    'Exec',        'Exit',        'Exp',
        'FExpand',    'FilePos',    'FileSize',    'FillChar',    'FindFirst',
        'FindNext',    'First',    'Flush',    'Frac',        'FreeMem',
        'FSearch',    'FSplit',    'GetCBreak','GetDate',    'GetDir',
        'GetEnv',    'GetFAttr',    'GetFTime',    'GetIntVec','GetMem',
        'GetTime',    'GetVerify','GotoXY',    'Halt',        'Hi',
        'HighVideo','Inc',        'Insert',    'InsLine',    'Int',
        'Intr',        'IOResult',    'Keep',        'KeyPressed','Last',
        'Length',    'Ln',        'Lo',        'LowVideo',    'Mark',
        'MaxAvail',    'MemAvail',    'Member',    'MkDir',    'Move',
        'MsDos',    'New',        'NormVideo','NoSound',    'Odd',
        'Ofs',        'Ord',        'PackTime',    'ParamCount','ParamStr',
        'Pi',        'Pos',        'Pred',        'Ptr',        'Random',
        'Randomize','Read',        'ReadKey',    'Readln',    'Release',
        'Rename',    'Reset',    'Rewrite',    'RmDir',    'Round',
        'RunError',    'Seek',        'SeekEof',    'SeekEoln',    'Seg',
        'SetCBreak','SetDate',    'SetFAttr',    'SetFTime',    'SetIntVec',
        'SetTextBuf','SetTime',    'SetVerify','Sin',        'SizeOf',
        'Sound',    'SPtr',        'Sqr',        'Sqrt',        'SSeg',
        'Str',        'Succ',        'Swap',        'SwapVectors','TextBackground',
        'TextColor','TextMode',    'Trunc',    'Truncate',    'UnpackTime',
        'UpCase',    'Val',        'WhereX',    'WhereY',    'Window',
        'Write',    'Writeln');

    BEGIN
        IsFuncProc :=
            TokenMatch(Token, FuncProcs, FuncProcCnt, Shortest, Longest);
    END;

FUNCTION IsVar (VAR Token : STRING) : Boolean;

    CONST
        VarCnt = 35;                        { Number Of Variables }
        Shortest = 3;
        Longest = 11;

    TYPE
        VarsArray = ARRAY[1..VarCnt] OF SmallStr;

    CONST
        Vars : VarsArray = (
        'CheckBreak','CheckEOF','CheckSnow','DirectVideo','DosError',
        'Input',    'LastMode',    'Lst',        'Mem',        'MemL',
        'MemW',        'Output',    'Port',        'PortW',    'SaveInt00',
        'SaveInt02','SaveInt1B','SaveInt23','SaveInt24','SaveInt34',
        'SaveInt35','SaveInt36','SaveInt37','SaveInt38','SaveInt39',
        'SaveInt3A','SaveInt3B','SaveInt3C','SaveInt3D','SaveInt3E',
        'SaveInt3F','SaveInt75','TextAttr',    'WindMax',    'WindMin');

    BEGIN
        IsVar :=
            TokenMatch(Token, Vars, VarCnt, Shortest, Longest);
    END;

FUNCTION IsCode(VAR Token : STRING) : Boolean;

    VAR
        CodeTbl : StmtPtr;
        LastTbl : StmtPtr;
        TokStr : STRING;
        TokLen : Word;
        LPtrSize : LongInt;

    BEGIN
        TokStr := UpperStr(Token);
        TokLen := Length(Token);
        CodeTbl := CodeStmts;
        LastTbl := CodeStmts;

        WHILE (CodeTbl <> NIL) DO
            BEGIN
                IF (TokLen = Length(CodeTbl^.Stmt)) AND
                   (TokStr = UpperStr(CodeTbl^.Stmt)) THEN
                        BEGIN
                            Token := CodeTbl^.Stmt;
                            IsCode := True;
                            Exit;
                        END
                ELSE
                    BEGIN
                        LastTbl := CodeTbl;
                        CodeTbl := CodeTbl^.Next;
                    END;
            END;

        IF (CodeStmts = NIL) THEN
            BEGIN
                Mark(CodeStmts);
                LastTbl := CodeStmts;
            END;

        TokLen := SizeOf(StmtPtr) + Length(Token) + 1;
        LPtrSize := TokLen;
        GetMem(CodeTbl, TokLen);
        LastTbl^.Next := CodeTbl;
        CodeTbl^.Stmt := Token;
        CodeTbl^.Next := NIL;
        IsCode := False;
    END;

FUNCTION IsComment(VAR Flag : Boolean;
                   VAR NeedToken : STRING;
                   VAR Token : STRING) : Boolean;

    BEGIN
        IF Flag AND (TokenType = Other) THEN
            IF (Pos(NeedToken, Token) <> 0) THEN
                BEGIN
                    Flag := False;
                    NeedToken := '';
                END
            ELSE
                Flag := True
        ELSE
            IF (Pos('{', Token) <> 0) THEN
                BEGIN
                    Flag := True;
                    NeedToken := '}';
                END
            ELSE
                IF (Pos('(*', Token) <> 0) THEN
                    BEGIN
                        Flag := True;
                        NeedToken := '*)'
                    END;

        IsComment := Flag;
    END;

FUNCTION HaveCmdParams : Boolean;

    VAR
        i : Integer;
        TmpStr : STRING;

    PROCEDURE AddExtension;

        BEGIN
            IF (Pos('.', TmpStr) = 0) THEN
                TmpStr := Concat(TmpStr, '.PAS');
        END;

    BEGIN
        IF (ParamCount < 1) OR (ParamCount > 2) THEN
            BEGIN
                Writeln('Usage: QPF InFileName [OutFileName]');
                HaveCmdParams := False;
            END
        ELSE
            BEGIN
                TmpStr := ParamStr(1);
                AddExtension;
                InFileName := UpperStr(TmpStr);

                IF (ParamCount = 2) THEN
                    BEGIN
                        TmpStr := ParamStr(2);
                        AddExtension;
                        OutFileName := UpperStr(TmpStr);
                    END
                ELSE
                    OutFileName := InFileName;
                HaveCmdParams := True;
            END;
    END;

FUNCTION LoadedOK : Boolean;

    VAR
        InFile : Text;
        InStmt : STRING;
        LastStmt : StmtPtr;

    FUNCTION OpenOk : Boolean;

        VAR
            Status : Word;

        BEGIN
            Assign(InFile, InFileName);
            Reset(InFile);
            Status := IOResult;
            IF (Status = 0) THEN
                OpenOk := True
            ELSE
                BEGIN
                    Writeln('Error ',Status,' Opening ', InFileName);
                    OpenOk := False
                END;
        END;

    PROCEDURE StoreStmt;

        VAR
            PtrSize : Word;
            NewStmt : StmtPtr;

        BEGIN
            PtrSize := SizeOf(StmtPtr) + Length(InStmt) + 1;
            IF (ProgStmts = NIL) THEN
                Mark(ProgStmts);
            GetMem(NewStmt, PtrSize);
            IF (LastStmt = NIL) THEN
                LastStmt := ProgStmts
            ELSE
                LastStmt^.Next := NewStmt;
            NewStmt^.Stmt := InStmt;
            NewStmt^.Next := NIL;
            LastStmt := NewStmt;
        END;

    BEGIN
        LastStmt := NIL;                    { Init Statement Array }
        IF NOT OpenOk THEN
            LoadedOK := False
        ELSE
            BEGIN
                WHILE NOT Eof(InFile) DO
                    BEGIN
                        Readln(InFile, InStmt);
                        StoreStmt;
                    END;
                LoadedOK := True;
                Close(InFile);
            END;
    END;

PROCEDURE GetToken(VAR Stmt : STRING;  VAR StartPos, EndPos : Word);

    CONST
        SpaceChrs : SET OF Char = [' ',#9];

    VAR
        StmtLen,CurPos : Word;
        Ch : Char;
        Flg : Boolean;

    PROCEDURE Build_Ident;

        BEGIN
            StartPos := CurPos;
            TokenType := Identifier;
            WHILE (CurPos <= StmtLen) AND
                  (Stmt[CurPos] IN (IdentSet + DigitSet)) DO
                BEGIN
                    Token := Token + Stmt[CurPos];
                    EndPos := CurPos;
                    Inc(CurPos);
                END;
        END;

    PROCEDURE Build_Token;

        BEGIN
            StartPos := CurPos;
            TokenType := Other;
            WHILE (CurPos <= StmtLen) AND (Stmt[CurPos] IN DelimSet) DO
                BEGIN
                    Token := Token + Stmt[CurPos];
                    EndPos := CurPos;
                    Inc(CurPos);
                END;
        END;

    PROCEDURE Build_Literal;

    TYPE
        Literals = (Quoted, Hex, Decimal, Float);
        Char_Set = SET OF Char;

    VAR
        Literal_Type : Literals;
        CurSet : Char_Set;

        BEGIN
            StartPos := CurPos;
            TokenType := Literal;
            CASE Stmt[CurPos] OF
                '0'..'9':
                    BEGIN
                        Literal_Type := Float;
                        CurSet := DigitSet + ['.'];
                    END;
                '''':
                    BEGIN
                        Literal_Type := Quoted;
                        CurSet := [#0..#255];
                    END;
                '$':
                    BEGIN
                        Literal_Type := Hex;
                        CurSet := HexSet;
                    END;
                '#':
                    BEGIN
                        Literal_Type := Decimal;
                        CurSet := DigitSet;
                    END
                ELSE
                    Writeln('Unknown Token Type');
            END;

            Token := Token + Stmt[CurPos];
            EndPos := CurPos;
            Inc(CurPos);

            WHILE (CurPos <= StmtLen) AND
                  (Stmt[CurPos] IN CurSet) DO
                BEGIN
                    Token := Token + Stmt[CurPos];
                    EndPos := CurPos;
                    Inc(CurPos);
                    IF (Literal_Type = Quoted) AND
                       (Stmt[CurPos-1] = Quote) THEN
                        Exit;
                END;
        END;

    BEGIN
        StmtLen := Length(Stmt);
        Token := '';
        CurPos := StartPos;

        WHILE (CurPos <= StmtLen) AND (Stmt[CurPos] IN SpaceChrs) DO
            Inc(CurPos);

        WHILE (CurPos <= StmtLen) DO
            BEGIN
                Ch := Stmt[CurPos];
                IF (Ch IN IdentSet) THEN
                    BEGIN
                        Build_Ident;
                        Exit;
                    END;

                IF (Ch IN DelimSet) THEN
                    BEGIN
                        Build_Token;
                        Exit;
                    END;

                IF (Ch IN DigitSet) OR (Ch IN LiteralSet) THEN
                    BEGIN
                        Build_Literal;
                        Exit;
                    END;

                Inc(CurPos);
            END;
    END;

PROCEDURE FormatIn;

    VAR
        SkipFlg : Boolean;
        SkipToken : STRING;
        CurStmt : StmtPtr;
        TStart, TEnd : Word;

    PROCEDURE AnalyzeToken;

        BEGIN
            IF (SkipFlg) AND IsComment(SkipFlg, SkipToken, Token) THEN
                Exit;

            CASE TokenType OF
                Identifier :
                    BEGIN
                        IF IsKeyWord(Token) OR
                           IsFuncProc(Token) OR
                           IsDataType(Token) OR
                           IsVar(Token) OR
                           IsConst(Token) OR
                           IsCode(Token) THEN
                            Move(Token[1],
                                 CurStmt^.Stmt[TStart],
                                 Length(Token));
                    END;
                Other:
                    IF IsComment(SkipFlg, SkipToken, Token) THEN
                        Exit;
                Literal:
                    Exit;
            END;
        END;

    BEGIN    { Procedure FormatIn }
        CurStmt := ProgStmts;
        SkipFlg := False;
        SkipToken := '';
        LineCnt := 0;
        Write(InFileName, '(');
        WHILE(CurStmt <> NIL) DO
            BEGIN
                TStart := 1;
                TEnd := 1;
                Inc(LineCnt);
                WHILE (TStart <= Length(CurStmt^.Stmt)) DO
                    BEGIN
                        GetToken(CurStmt^.Stmt, TStart, TEnd);
                        AnalyzeToken;
                        TStart := TEnd + 1;
                    END;
                CurStmt := CurStmt^.Next;
                IF (LineCnt MOD 10 = 0) THEN
                    BEGIN
                        Write(LineCnt,')',Chr(8));
                        TStart := LineCnt;
                        REPEAT
                            Write(Chr(8));
                            TStart := TStart DIV 10;
                        UNTIL (TStart = 0);
                    END;
            END;
    END;

PROCEDURE FormatOut;

    VAR
        OutFile : Text;
        CurStmt : StmtPtr;

    BEGIN
        CurStmt := ProgStmts;
        Assign(OutFile, OutFileName);
        Rewrite(OutFile);
        LineCnt := 0;
        WHILE (CurStmt <> NIL) DO
            BEGIN
                Writeln(OutFile, CurStmt^.Stmt);
                CurStmt := CurStmt^.Next;
                Inc(LineCnt);
            END;
        Release(ProgStmts);
        Close(OutFile);
    END;

PROCEDURE ShowStats;

    TYPE
        STR2 = STRING[2];

    FUNCTION NumStr2(Num : Word) : STR2;

        VAR
            NumStr : STRING;

        BEGIN
            Str(Num+100:3, NumStr);
            NumStr2 := Copy(NumStr, 2, 2);
        END;

    VAR
        STime,Etime : LongInt;
        EHrs,EMin,ESec,EHnd : Word;            { End Times }
        TimeStr : STRING;

    BEGIN
        GetTime(EHrs, EMin, ESec, EHnd);
        STime := (SMin * 60 + SSec) * 100 + SHnd;
        STime := STime + LongInt (SHrs) * 36000;
        Etime := (EMin * 60 + ESec) * 100 + EHnd;
        Etime := Etime + LongInt (EHrs) * 36000;
        Etime := Etime - STime;
        EHnd := Etime MOD 100;
        Etime := Etime DIV 100;
        EHrs := Etime DIV 3600;
        Etime := Etime MOD 3600;
        EMin := Etime DIV 60;
        ESec := Etime MOD 60;
        TimeStr := NumStr2(EHrs) + ':' +
                   NumStr2(EMin) + ':' +
                   NumStr2(ESec) + '.' + NumStr2(EHnd);
        Writeln;
        Writeln('Lines: ',LineCnt);
        Writeln('Elapsed Time = ',TimeStr);
    END;

BEGIN    { Program Start }
    CodeStmts := NIL;
    ProgStmts := NIL;

    Writeln('MAT Enterprises, Quick Pascal Word Fixup  V1.0');
    Writeln;
    IF HaveCmdParams THEN
        BEGIN
            GetTime(SHrs, SMin, SSec, SHnd);
            IF LoadedOK THEN
                BEGIN
                    FormatIn;
                    FormatOut;
                    ShowStats
                END;
        END;
END.